home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
User's Choice Windows CD
/
User's Choice Windows CD (CMS Software)(1993).iso
/
win_m_p
/
prvw13.zip
/
WOPLUS.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1991-07-24
|
10KB
|
380 lines
{WOPLUS - Extensions to ObjectWindows Copyright (C) Doug Overmyer 7/1/91}
unit WOPlus;
{******************************************************************}
{ I N T E R F A C E }
{******************************************************************}
interface
uses WinTypes, WinProcs, WinDos, Strings, WObjects,StdDlgs;
type
PODButton = ^TODButton;
TODButton = object(TButton)
HBmp :HBitmap;
State:Integer;
constructor Init(AParent:PWindowsObject; AnID:Integer;ATitle:PChar;
X,Y,W,H:Integer;IsDefault:Boolean;BMP:PChar);
destructor Done;virtual;
procedure DrawItem(var Msg:TMessage);virtual;
end;
type
PStackStr = ^TStackStr;
TStackStr = object(TObject)
StackStr:PChar;
constructor Init(NewStr:PChar);
destructor Done;virtual;
end;
type
PStackInt = ^TStackInt;
TStackInt = object(TObject)
StackInt:Integer;
constructor Init(NewInt:Integer);
destructor Done;virtual;
end;
type
PStack = ^TStack;
TStack = object(TCollection)
procedure Push(Item:Pointer);virtual;
function Pop:Pointer;virtual;
end;
{TTextStream}
type
PTextStream = ^TTextStream ;
TTextStream = object(TBufStream)
CharsToRead : LongInt;
CharsRead : LongInt;
ARecord :PChar;
constructor Init(FileName:PChar;Mode,Size:Word);
destructor Done;virtual;
function GetNext:PChar;virtual;
function WriteNext(szARecord:PChar):integer;virtual;
function WriteEOF:integer;virtual;
function IsEOF:Boolean;virtual;
function GetPctDone:Integer;
end;
{TMeter}
type
PMeterWindow = ^TMeterWindow;
TMeterWindow = object(TWindow)
TheRedBrush:HBrush;
TheBlueBrush:Hbrush;
ThePen:HPen;
X,Y,dX,dY,mX :Integer;
PctDone :Integer;
constructor Init(AParent:PWindowsObject;ATitle:PChar);
procedure SetupWindow;virtual;
destructor Done; virtual;
procedure Draw(NewPctDone:Integer);virtual;
procedure Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);virtual;
end;
{********************************************************************}
{I M P L E M E N T A T I O N }
{********************************************************************}
implementation
{***********************************************************************}
constructor TODButton.Init(AParent:PWindowsObject; AnID:Integer;ATitle:PChar;
X,Y,W,H:Integer;IsDefault:Boolean;BMP:PChar);
begin
TButton.Init(AParent,AnID,ATitle,X,Y,W,H,IsDefault);
Attr.Style := Attr.Style or bs_OwnerDraw;
HBmp := LoadBitmap(HInstance,BMP);
end;
destructor TODButton.Done;
begin
TButton.Done;
DeleteObject(HBmp);
end;
procedure TODButton.DrawItem(var Msg:TMessage);
var
TheDC:HDc;
ThePen:HPen;
Pen1:HPen;
Pen2:HPen;
TheBrush :HBrush;
OldBrush :HBrush;
OldPen:HPen;
OldBitMap:HBitMap;
MemDC :HDC;
LPts:Array[0..2] of TPoint;
RPts:Array[0..2] of TPoint;
PDIS :^TDrawItemStruct;
X,Y,W,H:Integer;
begin
PDIS := Pointer(Msg.lParam);
if PDIS^.itemAction = oda_Focus then Exit;
if ((PDIS^.itemAction and oda_Select ) > 0) and
((PDIS^.itemState and ods_Selected) > 0) then
State := 1 else State := 0; ;
X := PDIS^.rcItem.left;Y := PDIS^.rcItem.top;
W := PDIS^.rcItem.right-PDIS^.rcItem.left;
H := PDIS^.rcItem.bottom-PDIS^.rcItem.top;
LPts[0].x := W; LPts[0].y := 0;
LPts[1].x := 0; LPts[1].y := 0;
LPts[2].x := 0; LPts[2].y := H;
RPts[0].x := 0; RPts[0].y := H;
RPts[1].x := W; RPts[1].y := H;
RPts[2].x := W; RPts[2].y := 0;
MemDC := CreateCompatibleDC(PDIS^.HDC);
OldBitMap := SelectObject(MemDC,HBMP);
if State = 0 then
BitBlt(PDIS^.HDC,X,Y,W,H, MemDC,0,0,SrcCopy)
else
BitBlt(PDIS^.HDC,X+2,Y+2,W,H, MemDC,0,0,SrcCopy);
SelectObject(MemDC,OldBitMap);
DeleteDC(MemDC);
Pen1 := CreatePen(ps_Solid,2,$00000000);
OldPen := SelectObject(PDIS^.HDC,Pen1);
PolyLine(PDIS^.HDC,LPts,3);
PolyLine(PDIS^.HDC,RPts,3);
SelectObject(PDIS^.HDC,OldPen);
DeleteObject(Pen1);
LPts[0].x := W-2; LPts[0].y := 2;
LPts[1].x := 2; LPts[1].y := 2;
LPts[2].x := 2;LPts[2].y := H-2;
RPts[0].x := 1; RPts[0].y := H-1;
RPts[1].x := W-1; RPts[1].y := H-1;
RPts[2].x := W-1; RPts[2].y := 1;
if State = 0 then
begin
Pen1 := CreatePen(ps_Solid,2,$00FFFFFF);
Pen2 := CreatePen(ps_Solid,2,$00808080);
end
else
begin
Pen2 := CreatePen(ps_Solid,1,$00808080);
Pen1 := CreatePen(ps_Solid,2,$00808080);
end;
OldPen := SelectObject(PDIS^.HDC,Pen1);
PolyLine(PDIS^.HDC,LPts,3);
SelectObject(PDIS^.HDC,Pen2);
DeleteObject(Pen1);
PolyLine(PDIS^.HDC,RPts,3);
SelectObject(PDIS^.HDC,OldPen);
DeleteObject(Pen2);
end;
{***********************************************************************}
constructor TStackStr.Init(NewStr:PChar);
begin
StackStr := StrNew(NewStr);
end;
destructor TStackStr.Done;
begin
StrDispose(StackStr);
end;
{***********************************************************************}
constructor TStackInt.Init(NewInt:Integer);
begin
StackInt := NewInt;
end;
destructor TStackInt.Done;
begin
end;
{***********************************************************************}
procedure TStack.Push(Item:Pointer);
begin
AtInsert(0,Item);
end;
function TStack.Pop:Pointer;
begin
Pop := At(0);
AtDelete(0);
end;
{***********************************************************************}
{TTextStream Methods}
constructor TTextStream.Init(FileName:PChar; Mode,Size:Word);
begin
TBufStream.Init(FileName,Mode,Size);
CharsRead := 0;
CharsToRead := TBufStream.GetSize;
ARecord := MemAlloc(32000);
end;
{Done}
destructor TTextStream.Done;
begin
TBufStream.Done;
FreeMem(ARecord,32000);
end;
{GetNext}
function TTextStream.GetNext:PChar;
var
Blksize:Integer;
AChar:Char;
Indx : Integer;
IsEOR : Boolean;
begin
Indx := 0;
IsEOR := False;
ARecord[0] := #0;
while (CharsRead < CharsToRead) and (IsEOR = False) do
begin
TBufStream.Read(AChar,1);
Inc(CharsRead);
if (AChar = #13) then
begin
ARecord[Indx] := #0;
IsEOR := True;
end
else if (AChar = #10) then
begin
end
else if (AChar = #26) then
begin
end
else
begin
ARecord[Indx] := AChar;
inc(Indx);
end
end;
GetNext := ARecord;
end;
{WriteNext}
{This method not actually used due to performance loss - instead
TStream.Write is called directly}
function TTextStream.WriteNext(szARecord:PChar):Integer;
const
CRLF : Array[0..2] of Char = #13#10#0;
begin
TBufStream.Write(szARecord,
StrLen(szARecord));
TBufStream.Write(CRLF,2);
WriteNext := StrLen(szARecord);
end;
{WriteEOF}
function TTextStream.WriteEOF:Integer;
const
EOF : Array[0..1] of Char = #26;
begin
TBufStream.Write(EOF,1);
WriteEOF := 1;
end;
{IsEOF}
function TTextStream.IsEOF:Boolean;
begin
IsEOF := False;
if CharsRead >= CharsToRead then
IsEOF := True;
end;
{GetPctDone}
function TTextStream.GetPctDone:Integer;
begin
GetPctDone := CharsRead*100 div CharsToRead;
end;
{**********************************************************************}
{TMeterWindow Methods}
{Init}
constructor TMeterWindow.Init(Aparent:PWindowsObject;ATitle:PChar);
begin
TWindow.Init(AParent,ATitle);
DisableAutoCreate;
ThePen := CreatePen(ps_Solid,3,$00000000);
TheBlueBrush := CreateSolidBrush(RGB(0,0,255));
TheRedBrush := CreateSolidBrush(RGB(255,0,0));
with Attr do
begin
X := 100;Y :=100 ;W := 350;H := 75;
Style := ws_Popup or ws_Visible or ws_Border or ws_Caption;
end;
X := 50;
Y := 10;
dX := 275;
dY := 30;
mX := 50; {midpoint between X & X+dX}
PctDone := 0;
end;
procedure TMeterWindow.SetupWindow;
begin
TWindow.SetupWindow;
SetClassWord(HWindow,GCW_HICON,LoadIcon(HInstance,'WS_Icon'));
end;
{Done}
destructor TMeterWindow.Done;
begin
DeleteObject(TheBlueBrush);
DeleteObject(TheRedBrush);
DeleteObject(ThePen);
Destroy;
TWindow.Done;
end;
procedure TMeterWindow.Draw(NewPctDone:Integer);
begin
PctDone := NewPctDone;
If PctDone > 0 then
mX := X + ((dX * PctDone) div 100)
else
mX := X;
InvalidateRect(HWindow,nil,True);
UpdateWindow(HWindow);
end;
procedure TMeterWindow.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
var
OldBrush : HBrush;
OldPen :HPen;
OldColor : LongInt;
OldBkMode : Integer;
Buf : Array[0..5] of Char;
begin
DrawIcon(PaintDC,10,10,GetClassWord(HWindow,GCW_HICON));
OldPen := SelectObject(PaintDC,ThePen);
OldBrush := SelectObject(PaintDC,TheRedBrush);
Rectangle(PaintDC,X,Y,mX,Y+dY);
SelectObject(PaintDC,TheBlueBrush);
Rectangle(PaintDC,mX,Y,X+dX,Y+dY);
Str(PctDone:4, Buf);
StrCat(Buf,'%');
OldColor := SetTextColor(PaintDC,$00FFFFFF); {White}
OldBkMode := SetBkMode(PaintDC,Transparent);
TextOut(PaintDC,165,17,Buf,StrLen(Buf));
SelectObject(PaintDC,OldBrush);
SelectObject(PaintDC,OldPen);
SetTextColor(PaintDC,Oldcolor);
SetBkMode(PaintDC,OldBkMode);
end;
{***********************************************************************}
end.